home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / display.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  19KB  |  466 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (export '(
  24.       with-display
  25.       with-event-queue
  26.       open-display
  27.       display-force-output
  28.       close-display
  29.       display-protocol-version
  30.       display-vendor
  31.       display-roots
  32.       display-motion-buffer-size
  33.       display-max-request-length
  34.       display-error-handler
  35.       display-after-function
  36.       display-invoke-after-function
  37.       display-finish-output))
  38.  
  39. ;;
  40. ;; Resource id management
  41. ;;
  42. (defun initialize-resource-allocator (display)
  43.   ;; Find the resource-id-byte (appropriate for LDB & DPB) from the resource-id-mask
  44.   (let ((id-mask (display-resource-id-mask display)))
  45.     (unless (zerop id-mask) ;; zero mask is an error
  46.       (do ((first 0 (index1+ first))
  47.        (mask id-mask (the mask32 (ash mask -1))))
  48.       ((oddp mask)
  49.        (setf (display-resource-id-byte display)
  50.          (byte (integer-length mask) first)))
  51.     (declare (type array-index first)
  52.          (type mask32 mask))))))
  53.  
  54. (defun resourcealloc (display)
  55.   ;; Allocate a resource-id for in DISPLAY
  56.   (declare (type display display))
  57.   (declare-values resource-id)
  58.   (dpb (incf (display-resource-id-count display))
  59.        (display-resource-id-byte display)
  60.        (display-resource-id-base display)))
  61.  
  62. (defmacro allocate-resource-id (display object type)
  63.   ;; Allocate a resource-id for OBJECT in DISPLAY
  64.   (declare (type display display)
  65.        (type t object))
  66.   (declare-values resource-id)
  67.   (if (member (eval type) *clx-cached-types*)
  68.       `(let ((id (funcall (display-xid ,display) ,display)))
  69.      (save-id ,display id ,object)
  70.      id)
  71.     `(funcall (display-xid ,display) ,display)))
  72.  
  73. (defmacro deallocate-resource-id (display id type)
  74.   ;; Deallocate a resource-id for OBJECT in DISPLAY
  75.   (when (member (eval type) *clx-cached-types*)
  76.     `(deallocate-resource-id-internal ,display ,id)))
  77.  
  78. (defun deallocate-resource-id-internal (display id)
  79.   (remhash id (display-resource-id-map display)))
  80.  
  81. (defun lookup-resource-id (display id)
  82.   ;; Find the object associated with resource ID
  83.   (gethash id (display-resource-id-map display)))
  84.  
  85. (defun save-id (display id object)
  86.   ;; Register a resource-id from another display.
  87.   (declare (type display display)
  88.        (type integer id)
  89.        (type t object))
  90.   (declare-values object)
  91.   (setf (gethash id (display-resource-id-map display)) object))
  92.  
  93. (defun make-xatom (&key display id)
  94.   (atom-name-internal display id))
  95.  
  96. ;; Define functions to find the CLX data types given a display and resource-id
  97. ;; If the data type is being cached, look there first.
  98. (eval-when (eval compile)  ;; I'd rather use macrolet, but Symbolics doesn't like it...
  99.  
  100. (defmacro generate-lookup-functions (useless-name &body types)
  101.   `(within-definition (,useless-name generate-lookup-functions)
  102.      ,@(mapcar
  103.      #'(lambda (type)
  104.          `(defun ,(xintern 'lookup- type)
  105.              (display id)
  106.         (declare (type display display)
  107.              (type resource-id id))
  108.         (declare-values ,type)
  109.         ,(if (member type *clx-cached-types*)
  110.              `(let ((,type (lookup-resource-id display id)))
  111.             (cond ((null ,type) ;; Not found, create and save it.
  112.                    (setq ,type (,(xintern 'make- type)
  113.                         :display display :id id))
  114.                    (save-id display id ,type))
  115.                   ;; Found.  Check the type
  116.                   ,(cond ((null *type-check?*)
  117.                       `(t ,type))
  118.                      ((member type '(window pixmap))
  119.                       `((type? ,type 'drawable) ,type))
  120.                      (t `((type? ,type ',type) ,type)))
  121.                   ,@(when *type-check?*
  122.                   `((t (x-error 'lookup-error
  123.                         :id id
  124.                         :display display
  125.                         :type ',type
  126.                         :object ,type))))))
  127.            ;; Not being cached.  Create a new one each time.
  128.            `(,(xintern 'make- type)
  129.              :display display :id id))))
  130.      types)))
  131. ) ;; End eval-when
  132.  
  133. (generate-lookup-functions ignore
  134.   drawable
  135.   window
  136.   pixmap
  137.   gcontext
  138.   cursor
  139.   colormap
  140.   font
  141.   xatom)
  142.  
  143. (defun atom-id (atom display)
  144.   ;; Return the ID for an atom in DISPLAY
  145.   (declare (type xatom atom)
  146.        (type display display))
  147.   (declare-values (or null resource-id))
  148.   (gethash (if (keywordp atom)
  149.            atom
  150.            (kintern atom))
  151.        (display-atom-cache display)))
  152.  
  153. (defun set-atom-id (atom display id)
  154.   ;; Set the ID for an atom in DISPLAY
  155.   (declare (type xatom atom)
  156.        (type display display)
  157.        (type resource-id id))
  158.   (declare-values resource-id)
  159.   (setf (gethash (if (keywordp atom)
  160.              atom
  161.              (kintern atom))
  162.          (display-atom-cache display))
  163.     id))
  164.  
  165. (defsetf atom-id set-atom-id)
  166.  
  167. (defun initialize-predefined-atoms (display)
  168.   (do ((i 1 (1+ i))
  169.        (end (length *predefined-atoms*))
  170.        (save-p (member 'xatom *clx-cached-types*)))
  171.       ((>= i end))
  172.     (set-atom-id (aref *predefined-atoms* i) display i)
  173.     (when save-p
  174.       (save-id display i (aref *predefined-atoms* i)))))
  175.  
  176.  
  177. ;;
  178. ;; Display functions
  179. ;;
  180. (defmacro with-display ((display) &body body)
  181.   ;; This macro is for use in a multi-process environment.  It provides exclusive
  182.   ;; access to the local display object for multiple request generation.  It need not
  183.   ;; provide immediate exclusive access for replies; that is, if another process is
  184.   ;; waiting for a reply (while not in a with-display), then synchronization need not
  185.   ;; (but can) occur immediately.  Except where noted, all routines effectively
  186.   ;; contain an implicit with-display where needed, so that correct synchronization
  187.   ;; is always provided at the interface level on a per-call basis.  Nested uses of
  188.   ;; this macro will work correctly.  This macro does not prevent concurrent event
  189.   ;; processing; see with-event-queue.
  190.   `(with-buffer (,display) ,@body))
  191.  
  192. (defmacro with-event-queue ((display) &body body)
  193.   ; exclusive access to event queue
  194.   (declare (special *within-with-event-queue*))
  195.   (if (and (boundp '*within-with-event-queue*) *within-with-event-queue*)
  196.       `(progn ,display ,@body) ;; Speedup hack for lexically nested with-event-queue's
  197.     `(compiler-let ((*within-with-event-queue* t))
  198.        (holding-lock ((display-event-lock ,display) "Event-Lock") ,@body))))
  199.  
  200. (defmacro with-event-queue-internal ((display) &body body)
  201.   ; exclusive access to the internal event queues
  202.   `(holding-lock ((display-event-queue-lock ,display) "Event-Queue-Lock") ,@body))
  203.  
  204. (defmacro with-input-lock ((display) &body body)
  205.   ; exclusive access to the input buffer
  206.   `(holding-lock ((display-input-lock ,display) "Input-Lock") ,@body))
  207.  
  208. (defun open-display (host  &rest options &key (display 0) protocol
  209.              authorization-name authorization-data &allow-other-keys)
  210.   ;; Implementation specific routine to setup the buffer for a specific host and display.
  211.   ;; This must interface with the local network facilities, and will probably do special
  212.   ;; things to circumvent the nework when displaying on the local host.
  213.   ;;
  214.   ;; A string must be acceptable as a host, but otherwise the possible types
  215.   ;; for host and protocol are not constrained, and will likely be very
  216.   ;; system dependent.  The default protocol is system specific.  Authorization,
  217.   ;; if any, is assumed to come from the environment somehow.
  218.   (declare (type integer display))
  219.   (declare-values display)
  220.   ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
  221.   (let* ((stream (open-x-stream host display protocol))
  222.      (disp (apply #'make-buffer
  223.               #x1000 #x1000 'make-display-internal
  224.               :host host
  225.               :display display
  226.               :output-stream stream
  227.               :input-stream stream
  228.               #-ti :allow-other-keys #-ti t    ; Explorer 4.1 is broken
  229.               options))
  230.      (ok-p nil))
  231.     (unwind-protect
  232.     (progn
  233.       (display-connect disp :authorization-name authorization-name :authorization-data authorization-data)
  234.       (initialize-resource-allocator disp)
  235.       (initialize-predefined-atoms disp)
  236.       (initialize-extensions disp)
  237.       (setq ok-p t))
  238.       (unless ok-p (close-display disp))) ;; Ensure network connection gets closed on connect problems
  239.     disp))
  240.  
  241. (defun display-force-output (display)
  242.   ; Output is normally buffered, this forces any buffered output to the server.
  243.   (declare (type display display))
  244.   (with-display (display)
  245.     (buffer-force-output display)))
  246.  
  247. (defun close-display (display)
  248.   ;; Close the host connection in DISPLAY
  249.   (declare (type display display))
  250.   (close-buffer display))
  251.  
  252. (defun display-connect (display &key authorization-name authorization-data)
  253.   (unless authorization-name (setq authorization-name ""))
  254.   (unless authorization-data (setq authorization-data ""))
  255.   (writing-buffer-send (display :sizes (8 16))
  256.     (card8-put 0
  257.            #+clx-little-endian
  258.            #x6c ;; Ascii lowercase l - Least Significant byte first
  259.            #-clx-little-endian
  260.            #x42 ;; Ascii uppercase B -  Most Significant Byte First
  261.            )
  262.     (card16-put 2 *protocol-major-version*)
  263.     (card16-put 4 *protocol-minor-version*)
  264.     (card16-put 6 (length authorization-name))
  265.     (card16-put 8 (length authorization-data))
  266.     (write-sequence-char display 12 authorization-name)
  267.     (write-sequence-char display
  268.              (lround (+ 12 (length authorization-name))) authorization-data))
  269.   (buffer-force-output display)
  270.   (reading-buffer-reply (display :sizes (8 16 32))
  271.     (buffer-input display buffer-bbuf 0 8)
  272.     (let ((success (boolean-get 0))
  273.       (reason-length (card8-get 1))
  274.       (major-version (card16-get 2))
  275.       (minor-version (card16-get 4))
  276.       (total-length (card16-get 6))
  277.       vendor-length
  278.       num-roots
  279.       num-formats)
  280.       (declare (ignore total-length))
  281.       (unless success
  282.     (x-error 'connection-failure
  283.          :major-version major-version
  284.          :minor-version minor-version
  285.          :host (display-host display)
  286.          :display (display-display display)
  287.          :reason (string-get reason-length)))
  288.       (buffer-input display buffer-bbuf 0 32)
  289.       (setf (display-protocol-major-version display) major-version)
  290.       (setf (display-protocol-minor-version display) minor-version)
  291.       (setf (display-release-number display) (card32-get 0))
  292.       (setf (display-resource-id-base display) (card32-get 4))
  293.       (setf (display-resource-id-mask display) (card32-get 8))
  294.       (setf (display-motion-buffer-size display) (card32-get 12))
  295.       (setq vendor-length (card16-get 16))
  296.       (setf (display-max-request-length display) (card16-get 18))
  297.       (setq num-roots (card8-get 20))
  298.       (setq num-formats (card8-get 21))
  299.       ;; Get the image-info
  300.       (setf (display-image-lsb-first-p display) (zerop (card8-get 22)))
  301.       (let ((format (display-bitmap-format display)))
  302.     (declare (type bitmap-format format))
  303.     (setf (bitmap-format-lsb-first-p format) (zerop (card8-get 23)))
  304.     (setf (bitmap-format-unit format) (card8-get 24))
  305.     (setf (bitmap-format-pad format) (card8-get 25)))
  306.       (setf (display-min-keycode display) (card8-get 26))
  307.       (setf (display-max-keycode display) (card8-get 27))
  308.       ;; 4 bytes unused
  309.       ;; Get the vendor string
  310.       (setf (display-vendor-name display) (string-get vendor-length))
  311.       ;; Initialize the pixmap formats
  312.       (dotimes (i num-formats) ;; loop gathering pixmap formats
  313.     (buffer-input display buffer-bbuf 0 8)
  314.     (push (make-pixmap-format :depth (card8-get 0)
  315.                   :bits-per-pixel (card8-get 1)
  316.                   :scanline-pad (card8-get 2))
  317.                         ; 5 unused bytes
  318.           (display-pixmap-formats display)))
  319.       (setf (display-pixmap-formats display) (nreverse (display-pixmap-formats display)))
  320.       ;; Initialize the screens
  321.       (dotimes (i num-roots)
  322.     (buffer-input display buffer-bbuf 0 40)
  323.     (let* ((root (make-window :id (card32-get 0) :display display))
  324.            (screen
  325.          (make-screen
  326.            :root root
  327.            :default-colormap (make-colormap :id (card32-get 4) :display display)
  328.            :white-pixel (card32-get 8)
  329.            :black-pixel (card32-get 12)
  330.            :event-mask-at-open (card32-get 16)
  331.            :width  (card16-get 20)
  332.            :height (card16-get 22)
  333.            :width-in-millimeters  (card16-get 24)
  334.            :height-in-millimeters (card16-get 26)
  335.            :min-installed-maps (card16-get 28)
  336.            :max-installed-maps (card16-get 30)
  337.            :root-visual (card32-get 32)
  338.            :backing-stores (member8-get 36 :never :when-mapped :always)
  339.            :save-unders-p (boolean-get 37)
  340.            :root-depth (card8-get 38)))
  341.            (num-depths (card8-get 39))
  342.            (depths nil))
  343.       ;; Save root window for event reporting
  344.       (save-id display (window-id root) root)
  345.       ;; Create the depth AList for a screen, (depth . visual-infos)
  346.       (dotimes (j num-depths)
  347.         (buffer-input display buffer-bbuf 0 8)
  348.         (let ((depth (card8-get 0))
  349.           (num-visuals (card16-get 2))
  350.           (visuals nil)) ;; 4 bytes unused
  351.           (dotimes (k num-visuals)
  352.         (buffer-input display buffer-bbuf 0 24)
  353.         (push (make-visual-info
  354.             :id (card32-get 0)
  355.             :class (member8-get 4 :static-gray :gray-scale :static-color
  356.                            :pseudo-color :true-color :direct-color)
  357.             :bits-per-rgb (card8-get 5)
  358.             :colormap-entries (card16-get 6)
  359.             :red-mask (card32-get 8)
  360.             :green-mask (card32-get 12)
  361.             :blue-mask (card32-get 16))
  362.                 ;; 4 bytes unused
  363.               visuals))
  364.           (push (cons depth (nreverse visuals)) depths)))
  365.       (setf (screen-depths screen) (nreverse depths))
  366.       (push screen (display-roots display))))
  367.       (setf (display-roots display) (nreverse (display-roots display)))
  368.       (setf (display-default-screen display) (first (display-roots display)))))
  369.   display)
  370.  
  371. (defun display-protocol-version (display)
  372.   (declare (type display display))
  373.   (declare-values major minor)
  374.   (values (display-protocol-major-version display)
  375.       (display-protocol-minor-version display)))
  376.  
  377. (defun display-vendor (display)
  378.   (declare (type display display))
  379.   (declare-values name release)
  380.   (values (display-vendor-name display)
  381.       (display-release-number display)))
  382.  
  383. #+comment ;; defined by the DISPLAY defstruct
  384. (defsetf display-error-handler (display) (handler)
  385.   ;; All errors (synchronous and asynchronous) are processed by calling an error
  386.   ;; handler in the display.  If handler is a sequence it is expected to contain
  387.   ;; handler functions specific to each error; the error code is used to index the
  388.   ;; sequence, fetching the appropriate handler.  Any results returned by the handler
  389.   ;; are ignored; it is assumed the handler either takes care of the error
  390.   ;; completely, or else signals. For all core errors, the keyword/value argument
  391.   ;; pairs are:
  392.   ;;    :display display
  393.   ;;    :error-key error-key
  394.   ;;    :major integer
  395.   ;;    :minor integer
  396.   ;;    :sequence integer
  397.   ;;    :current-sequence integer
  398.   ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
  399.   ;; :window errors another pair is:
  400.   ;;    :resource-id integer
  401.   ;; For :atom errors, another pair is:
  402.   ;;    :atom-id integer
  403.   ;; For :value errors, another pair is:
  404.   ;;    :value integer
  405.   )
  406.  
  407.   ;; setf'able
  408.   ;; If defined, called after every protocol request is generated, even those inside
  409.   ;; explicit with-display's, but never called from inside the after-function itself.
  410.   ;; The function is called inside the effective with-display for the associated
  411.   ;; request.  Default value is nil.  Can be set, for example, to
  412.   ;; #'display-force-output or #'display-finish-output.
  413.  
  414. (defun display-invoke-after-function (display)
  415.   ; Called after every protocal request is generated
  416.   (declare (type display display)
  417.        (special *inside-display-after-function*))
  418.   (when (and (display-after-function display)
  419.          (not (and (boundp '*inside-display-after-function*)
  420.                *inside-display-after-function*)))
  421.     (let ((*inside-display-after-function* t)) ;; Ensure no recursive calls
  422.       (declare (special *inside-display-after-function*))
  423.       (funcall (display-after-function display) display))))
  424.  
  425. (defun display-finish-output (display)
  426.   ; Forces output, then causes a round-trip to ensure that all possible
  427.   ; errors and events have been received.
  428.   (declare (type display display))
  429.   (with-display (display)
  430.     (with-buffer-request (display *x-getinputfocus* :no-after))
  431.     (wait-for-reply display 16)))
  432.  
  433.  
  434. (defparameter
  435.   *request-names*
  436.   '#("error" "CreateWindow" "ChangeWindowAttributes" "GetWindowAttributes"
  437.      "DestroyWindow" "DestroySubwindows" "ChangeSaveSet" "ReparentWindow"
  438.      "MapWindow" "MapSubwindows" "UnmapWindow" "UnmapSubwindows"
  439.      "ConfigureWindow" "CirculateWindow" "GetGeometry" "QueryTree"
  440.      "InternAtom" "GetAtomName" "ChangeProperty" "DeleteProperty"
  441.      "GetProperty" "ListProperties" "SetSelectionOwner" "GetSelectionOwner"
  442.      "ConvertSelection" "SendEvent" "GrabPointer" "UngrabPointer"
  443.      "GrabButton" "UngrabButton" "ChangeActivePointerGrab" "GrabKeyboard"
  444.      "UngrabKeyboard" "GrabKey" "UngrabKey" "AllowEvents"
  445.      "GrabServer" "UngrabServer" "QueryPointer" "GetMotionEvents"
  446.      "TranslateCoords" "WarpPointer" "SetInputFocus" "GetInputFocus"
  447.      "QueryKeymap" "OpenFont" "CloseFont" "QueryFont"
  448.      "QueryTextExtents" "ListFonts" "ListFontsWithInfo" "SetFontPath"
  449.      "GetFontPath" "CreatePixmap" "FreePixmap" "CreateGC"
  450.      "ChangeGC" "CopyGC" "SetDashes" "SetClipRectangles"
  451.      "FreeGC" "ClearToBackground" "CopyArea" "CopyPlane"
  452.      "PolyPoint" "PolyLine" "PolySegment" "PolyRectangle"
  453.      "PolyArc" "FillPoly" "PolyFillRectangle" "PolyFillArc"
  454.      "PutImage" "GetImage" "PolyText8" "PolyText16"
  455.      "ImageText8" "ImageText16" "CreateColormap" "FreeColormap"
  456.      "CopyColormapAndFree" "InstallColormap" "UninstallColormap" "ListInstalledColormaps"
  457.      "AllocColor" "AllocNamedColor" "AllocColorCells" "AllocColorPlanes"
  458.      "FreeColors" "StoreColors" "StoreNamedColor" "QueryColors"
  459.      "LookupColor" "CreateCursor" "CreateGlyphCursor" "FreeCursor"
  460.      "RecolorCursor" "QueryBestSize" "QueryExtension" "ListExtensions"
  461.      "SetKeyboardMapping" "GetKeyboardMapping" "ChangeKeyboardControl" "GetKeyboardControl"
  462.      "Bell" "ChangePointerControl" "GetPointerControl" "SetScreenSaver"
  463.      "GetScreenSaver" "ChangeHosts" "ListHosts" "ChangeAccessControl"
  464.      "ChangeCloseDownMode" "KillClient" "RotateProperties" "ForceScreenSaver"
  465.      "SetPointerMapping" "GetPointerMapping" "SetModifierMapping" "GetModifierMapping"))
  466.